home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / examples / sketch.lisp < prev    next >
Encoding:
Text File  |  1990-07-19  |  13.7 KB  |  350 lines
  1. ;;; -*- Mode:Common-Lisp; Package:CLIO-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;                Copyright (C) 1990 Texas Instruments Incorporated.                |
  11. ;;;                              All Rights Reserved                                 |
  12. ;;;                                                                                  |
  13. ;;; Use, duplication, or disclosure by the Government is subject to  restrictions as |
  14. ;;; set forth in subdivision (b)(3)(ii) of the Rights in Technical Data and Computer |
  15. ;;; Software clause at 52.227-7013.                                                  |
  16. ;;;                                                                                  |
  17. ;;;----------------------------------------------------------------------------------+
  18.  
  19.  
  20. (in-package "CLIO-EXAMPLES")
  21.  
  22. (defconstant
  23.   *sketch-help*
  24.   "SKETCH  PAD  is  a  simple  drawing  editor.   You  can  draw  graphical
  25. primitives by  clicking  the  pointer  button  to  enter  vertex points.
  26. Complete a primitive by double-clicking on the final vertex.
  27.  
  28. Use the Graphics menu to select the type of primitive drawn.
  29.  
  30. Use the Attributes dialog to set attributes such as line width  and fill
  31. pattern.
  32.  
  33. Select Save from the File menu to save the drawing in a file. Select Open
  34. from the File menu to read another drawing for editing.
  35.  
  36. To quit, select Quit from the File menu.")
  37.  
  38. (defun sketch (&key (host *default-host*) foreground background width height)
  39.   "A simple picture editor."
  40.   (let*
  41.     (;; Open connection to the host server.
  42.      (display        (OPEN-CONTACT-DISPLAY 'sketch-pad :host host))     
  43.  
  44.      ;; Determine pixels for foreground and background.
  45.      (screen         (CONTACT-SCREEN (DISPLAY-ROOT display)))
  46.      (foreground     (or foreground (screen-black-pixel screen)))
  47.      (background     (or background (screen-white-pixel screen)))
  48.  
  49.      ;; Determine initial size of top-level-window.
  50.      (initial-width  (or width  400))
  51.      (initial-height (or height 400))
  52.  
  53.      ;; Create top-level window
  54.      (top            (MAKE-COMMAND-FRAME
  55.                        :parent    display
  56.  
  57.                        ;; Initialize standard top-level properties.
  58.                        :wm-title     "Sketch Pad"
  59.                        :wm-user-specified-size-p (and width height)
  60.  
  61.                        ;; Specify initial geometry.
  62.                        :x          0
  63.                        :y          0
  64.                        :width      initial-width
  65.                        :height     initial-height
  66.  
  67.                        ;; Set colors.
  68.                        :background background
  69.                        :foreground foreground
  70.  
  71.                        ;; Content is a scroll-frame containing a sketchpad.
  72.                        :content   `(MAKE-SCROLL-FRAME
  73.                                      :content (make-sketchpad
  74.                                                 :width  ,initial-width
  75.                                                 :height ,initial-height)))))
  76.  
  77.     (declare (special display top))
  78.  
  79.     ;; Initialize control buttons.
  80.     (let*
  81.       ((controls (COMMAND-FRAME-CONTROLS top))
  82.        (sketch   (SCROLL-FRAME-CONTENT (COMMAND-FRAME-CONTENT top))))
  83.       
  84.       ;; Build File menu
  85.       (let*
  86.         ((file-menu   (MAKE-MENU
  87.                         :parent     controls
  88.                         :name       :file 
  89.                         :title      "File"))
  90.          (choice      (MENU-CHOICE file-menu)))
  91.  
  92.         ;; Add control to display File menu.        
  93.         (MAKE-DIALOG-BUTTON
  94.           :parent     controls
  95.           :name       :file 
  96.           :dialog     file-menu
  97.           :label      "File")
  98.  
  99.         ;; Add File menu items.
  100.         (let ((help-item (MAKE-ACTION-ITEM
  101.                            :parent choice
  102.                            :name   :help
  103.                            :label  "Help")))
  104.           (ADD-CALLBACK
  105.             help-item :release                  ; Present help message when released.
  106.             'CONFIRM-P
  107.             :near        sketch
  108.             :message     *sketch-help*
  109.             :accept-only :on))
  110.         
  111.         ;; Build Open, Save dialogs...
  112.         (let*
  113.           ((open-dialog (MAKE-PROPERTY-SHEET
  114.                           :parent        controls
  115.                           :name          :open 
  116.                           :wm-title      "Sketch Pad Open")) 
  117.            (open-area   (PROPERTY-SHEET-AREA open-dialog))
  118.            
  119.            (save-dialog (MAKE-PROPERTY-SHEET
  120.                           :parent        controls
  121.                           :name          :save 
  122.                           :wm-title      "Sketch Pad Save")) 
  123.            (save-area   (PROPERTY-SHEET-AREA save-dialog)))
  124.           
  125.           ;; Add menu item to display Open dialog.
  126.           (MAKE-DIALOG-ITEM
  127.             :parent     choice
  128.             :name       :open 
  129.             :label      "Open"
  130.             :dialog     open-dialog)
  131.           
  132.           ;; Add menu item to display Save dialog.
  133.           (MAKE-DIALOG-ITEM
  134.             :parent     choice
  135.             :name       :save 
  136.             :label      "Save"
  137.             :dialog     save-dialog) 
  138.           
  139.           ;; Add members to Open dialog...
  140.           (MAKE-DISPLAY-TEXT-FIELD
  141.             :parent open-area :source "Open File:" :display-gravity :east) 
  142.  
  143.           (let*
  144.             ((initial-path  (nstring-downcase
  145.                               (namestring (make-pathname
  146.                                             :defaults (user-homedir-pathname)
  147.                                             :type "SKETCH"
  148.                                             :name "?")))) 
  149.              (open-field    (MAKE-EDIT-TEXT-FIELD
  150.                               :parent      open-area 
  151.                               :source      initial-path
  152.                               :length      (+ (length initial-path) 12)))
  153.              initial-value) 
  154.             
  155.             ;; Define callback functions for edit-text-field member.
  156.             (flet
  157.               ((open-file
  158.                  ()
  159.                  (with-open-file
  160.                    (in (DISPLAY-TEXT-SOURCE open-field) :direction :input)
  161.  
  162.                    (setf (sketchpad-picture sketch) (read in))
  163.                    (clear-area sketch :exposures-p t)))
  164.                
  165.                (open-initial-value
  166.                  ()
  167.                  (let*
  168.                    ((source (DISPLAY-TEXT-SOURCE open-field))
  169.                     (name   (pathname-name source))
  170.                     (point  (search name source :test #'char-equal)))
  171.                    (setf initial-value source)
  172.                    (setf (edit-text-point open-field) point)
  173.                    (setf (edit-text-mark open-field) (+ (length name) point))))
  174.                
  175.                (restore-initial-value
  176.                  ()
  177.                  (setf (DISPLAY-TEXT-SOURCE open-field) initial-value)))
  178.               
  179.               (ADD-CALLBACK open-field :initialize #'open-initial-value)
  180.               (ADD-CALLBACK open-field :accept     #'open-file)
  181.               (ADD-CALLBACK open-field :complete   #'dialog-accept open-dialog)
  182.               (ADD-CALLBACK open-field :cancel     #'restore-initial-value))
  183.           
  184.           
  185.             ;; Add members to Save dialog...
  186.             (MAKE-DISPLAY-TEXT-FIELD
  187.               :parent save-area :source "Save File:" :display-gravity :east) 
  188.  
  189.             (let
  190.               ((save-field (MAKE-EDIT-TEXT-FIELD
  191.                              :parent      save-area))) 
  192.               
  193.               ;; Define callback functions for edit-text-field member.
  194.               (flet
  195.                 ((save-file
  196.                    ()
  197.                    (with-open-file
  198.                      (out (DISPLAY-TEXT-SOURCE save-field) :direction :output)
  199.  
  200.                      (write (sketchpad-picture sketch) :stream out)))
  201.                  
  202.                  (initialize-file
  203.                    ()
  204.                    (let*
  205.                      ((source (DISPLAY-TEXT-SOURCE open-field))
  206.                       (name   (pathname-name source))
  207.                       (point  (search name source :test #'char-equal)))
  208.                      
  209.                      (setf (DISPLAY-TEXT-SOURCE save-field) source)
  210.                      (setf (EDIT-TEXT-FIELD-LENGTH save-field) (+ (length source) 12))
  211.                      (setf (EDIT-TEXT-POINT save-field) point)
  212.                      (setf (EDIT-TEXT-MARK save-field) (+ (length name) point)))))
  213.                 
  214.                 (ADD-CALLBACK save-field :initialize #'initialize-file)
  215.                 (ADD-CALLBACK save-field :accept     #'save-file)
  216.                 (ADD-CALLBACK save-field :complete   #'dialog-accept save-dialog)))))
  217.         
  218.         (MAKE-ACTION-ITEM
  219.           :parent    choice
  220.           :name      :quit
  221.           :label     "Quit" 
  222.           :callbacks (list
  223.                        (list :release           ; Exit event loop when released.
  224.                              (list #'(lambda () (throw :quit nil)))))))
  225.       
  226.       ;; Build Graphics menu
  227.       (let*
  228.         ((graphics-menu   (MAKE-MENU
  229.                             :parent     controls
  230.                             :name       :graphics 
  231.                             :title "Graphics"))
  232.          (choice          (MENU-CHOICE graphics-menu)))
  233.  
  234.         ;; Add control to display Graphics menu.        
  235.         (MAKE-DIALOG-BUTTON
  236.           :parent     controls
  237.           :name       :graphics 
  238.           :dialog     graphics-menu
  239.           :label      "Graphics") 
  240.  
  241.     (flet
  242.       ((setf-sketchpad-mode (mode sp) (setf (sketchpad-mode sp) mode)))
  243.       ;; Add Graphics menu items
  244.       (MAKE-ACTION-ITEM
  245.         :parent    choice
  246.         :name      :line
  247.         :label     "Line"
  248.         :callbacks `((:release        ; Change to :line mode when released.
  249.                (,#'setf-sketchpad-mode
  250.                 :line
  251.                 ,sketch))))
  252.       (MAKE-ACTION-ITEM
  253.         :parent    choice
  254.         :name      :polygon
  255.         :label     "Polygon"
  256.         :callbacks `((:release        ; Change to :polygon mode when released.
  257.                (,#'setf-sketchpad-mode
  258.                 :polygon
  259.                 ,sketch))))))
  260.       
  261.       ;; Build Attributes dialog
  262.       (let*
  263.         ((attributes-dialog (MAKE-PROPERTY-SHEET
  264.                               :parent        controls
  265.                               :name          :attributes 
  266.                               :wm-title      "Sketch Pad Attributes")) 
  267.          (area              (PROPERTY-SHEET-AREA attributes-dialog)))
  268.  
  269.         ;; Add control to display Attributes dialog.
  270.         (MAKE-DIALOG-BUTTON
  271.           :parent     controls
  272.           :name       :attributes 
  273.           :label      "Attributes"
  274.           :dialog     attributes-dialog)
  275.  
  276.         ;; Add members to Attributes dialog...
  277.         ;; ... a slider to change line width...
  278.         (MAKE-DISPLAY-TEXT-FIELD
  279.           :parent area :source "Line Width:" :display-gravity :east)
  280.         (let
  281.           ((slider (MAKE-SLIDER
  282.                      :parent      area
  283.                      :name        :line-width 
  284.                      :minimum     1
  285.                      :maximum     8
  286.                      :increment   1
  287.                      :orientation :horizontal))
  288.            initial-value)
  289.           
  290.           ;; Define callback functions for slider member.
  291.           (flet
  292.             ((set-line-width
  293.                () (setf (sketchpad-line-width sketch) (SCALE-VALUE slider)))
  294.              (save-initial-value
  295.                () (setf initial-value (SCALE-VALUE slider)))
  296.              (restore-initial-value
  297.                () (setf (SCALE-VALUE slider) initial-value)))
  298.             
  299.             (ADD-CALLBACK slider :initialize #'save-initial-value)
  300.             (ADD-CALLBACK slider :accept     #'set-line-width)
  301.             (ADD-CALLBACK slider :cancel     #'restore-initial-value)))
  302.         
  303.         
  304.         ;; ... and "radio-buttons"-style choices to change fill pattern.
  305.         (MAKE-DISPLAY-TEXT-FIELD
  306.           :parent area :source "Fill Pattern:" :display-gravity :east)
  307.         (let
  308.           ((choice (MAKE-CHOICES :parent area :name :fill :choice-policy :always-one))
  309.            initial-selection)
  310.  
  311.           ;; Define callback functions for choices member.
  312.           (flet
  313.             ((set-fill-pattern
  314.                () (setf (sketchpad-fill sketch)
  315.                         (APPLY-CALLBACK (CHOICE-SELECTION choice) :pattern)))
  316.              (save-initial-selection
  317.                () (setf initial-selection (CHOICE-SELECTION choice)))
  318.              (restore-initial-selection
  319.                () (setf (CHOICE-SELECTION choice) initial-selection)))
  320.  
  321.             (ADD-CALLBACK choice :initialize #'save-initial-selection)
  322.             (ADD-CALLBACK choice :accept     #'set-fill-pattern)
  323.             (ADD-CALLBACK choice :cancel     #'restore-initial-selection)
  324.  
  325.  
  326.             ;; Add choice items for each fill pattern. Define initial selection.
  327.             (MAKE-TOGGLE-BUTTON
  328.               :parent choice :label "White"
  329.               :callbacks `((:pattern (identity 0%gray))))
  330.             (MAKE-TOGGLE-BUTTON
  331.               :parent choice :label "Gray"
  332.               :callbacks `((:pattern (identity 50%gray))))
  333.             (setf (CHOICE-SELECTION choice)
  334.                   (MAKE-TOGGLE-BUTTON
  335.                     :parent choice :label "Black"
  336.                     :callbacks `((:pattern (identity 100%gray))))))))) 
  337.            
  338.     (unwind-protect
  339.         
  340.         ;; Main event loop.
  341.         (catch :quit
  342.           (loop
  343.             (PROCESS-NEXT-EVENT display)))
  344.  
  345.       ;; Destroy window and close connection to server.
  346.       (close-display display))))
  347.  
  348.  
  349.  
  350.